00100	C  THIS PROGRAM CREATES FUNCTIONS FOR THE MUSIC PROGRAM USING 'SEG' OR 'SYNTH'.
00200	C  UP TO 10 FUNCTIONS CAN BE STORED IN A SINGLE FILE.  ONCE CREATED THE
00300	C  FUNCTIONS MAY BE CHANGED AND PUT BACK IN THE SAME FILE OR INTO A NEW ONE.
00400	
00500		DIMENSION FUNC(512),A(50,4),B(21)
00600		COMMON ST(30),SU(270),K,I,IY
00700		DATA FAC/0.703125/
00800	C  FAC=360./512.
00900	40	FORMAT(11(A1,A3))
01000	41	FORMAT(' ADD TO AN EXISTING FILE?'/)
01100	42	FORMAT(' WHICH FUNC?'/)
01200	43	FORMAT(' NO ROOM IN FILE  "',A5,'.DAT"')
01300	44	FORMAT(' FUNCTIONS ALREADY IN FILE.')
01400	45	FORMAT('(512);')
01500	27	FORMAT(' 0=FIN, 1=REDEF'/)
01600	26	FORMAT(' TYPE AMPL, STEP#'/)
01700	25	FORMAT(' TYPE FILE NAME'/)
01800	24	FORMAT(' TYPE FUNCTION NAME'/)
01900	23	FORMAT(' SEG OR SYNTH?'/)
02000	22	FORMAT(' NEW FUNC, OLD OR DELETE ONE?'/)
02100	21	FORMAT(' CHANGE FUNC OR EXIT?'/)
02200	28	FORMAT(' -1=CLR,0=NORM,OR H,A,P,K'/)
02300	280	FORMAT(' THIS IS A NEW FORM OF ''FUNC'''/
02400		1' SEG USES 100 STEPS IN THIS PROGRAM!'/
02500		1' UP TO 10 FUNCTIONS MAY BE STORED IN EACH FILE'/
02600		1' (TYPE ''99'' TO BACKUP.)'/)
02700	30	FORMAT(8F)
02800	31	FORMAT(1XA5,A1,5A5/)
02900	CC32	FORMAT(9A1)
03000	CC33	FORMAT(7A5)
03100	34	FORMAT(A5,'(',A5,');',A5)
03200	35	FORMAT(1XA5,'IN FILE "',A5,'.DAT"'/)
03300	36	FORMAT(/' DELETE FOR20.DAT'/)
03400	37	FORMAT(8F9.3)
03500	38	FORMAT(2(A5,A1),23A2)
03600	39	FORMAT(A5,A1,10(A3,A1))
03700		TYPE 280
03800	281	KZ=0
03900		Z=0
04000	CC	Y='('
04100	CC	H=')'
04200		CALL FUNCT(FUNC)
04300		TYPE 22
04400	215	CALL DPYSET(1,ST,30)
04500		CALL DPYBRT(1)
04600		ACCEPT 40,ON
04700		IF(ON.EQ.'N')GO TO 100
04800		TYPE 25
04900		ACCEPT 39,FLNM
05000		REWIND 1
05100		CALL IFILE(1,FLNM)
05200		READ (1,39),X,B
05300		IF(B(3).EQ.' ')GO TO 402
05400		TYPE 40,B
05500		TYPE 42
05600		ACCEPT 39,FNUM
05700		IF(FNUM.EQ.'99')GO TO 281
05800		IF(ON.EQ.'D')GO TO 922
05900	CC	IF(FNUM.EQ.B(2))GO TO 151
06000	402	READ (1,39),K
06100	401	READ(1,38)X,Y,FNX,H
06200		IF(FNX.EQ.FNUM.OR.B(3).EQ.' ')GO TO 151
06300		GO TO 401
06400	151	TYPE 31,X,Y,FNX,H
06500		Z=-1.
06600		IF(X.EQ.'SEG')GO TO 802
06700		EY=0
06800		IF(Z)GO TO 1031
06900	100	TYPE 23
07000		ACCEPT 40,X,EY
07100	1032	CALL FUNCT(FUNC)
07200	C  CLEARS THE FUNC.
07300		IF(EY.EQ.'EG')GO TO 802
07400	1031	CALL ALINE(-160,0,356,0)
07500		CALL ALINE(-156,-256,-156,256)
07600		CALL DPYOUT(1)
07700	15	KT=1
07800	104	IF(Z)GO TO 103
07900		IF(KT.LT.KZ)GO TO 102
08000		KZ=0
08100		TYPE 28
08200		ACCEPT 30,(A(KT,K),K=1,4)
08300		GO TO 102
08400	CC115	CALL HYDPOG(2)
08500	115	CALL DPYSET(2,SU,270)
08600		CALL DPYBRT(6)
08700		CALL FUNCT(FUNC)
08800		GO TO 15
08900	1051	CALL DPYCLR
09000	105	KT=KT-1
09100		IF(KT.LT.1)GO TO 281
09200		KZ=KT
09300		GO TO 1032
09400	C   CLEARS ARRAY
09500	103	READ(1,30)(A(KT,K),K=1,4)
09600	102	H=A(KT,1)
09700		IF(H.EQ.0.OR.H.EQ.999.)GO TO 2200	CALL ALINE(-160,0,356,0)
07500		CALL ALINE(-156,-256,-156,256)
07600		CALL DPYOUT(1)
07700	15	KT=1
07800	104	IF(Z)GO TO 103
07900		IF(KT.LT.KZ)GO TO 102
08000		KZ=0
08100		TYPE 28
08200		ACCEPT 30,(A(KT,K),K=1,4)
08300		GO TO 102
08400	CC115	CALL HYDPOG(2)
08500	115	CALL DPYSET(2,SU,270)
08600		CALL DPYBRT(6)
08700		CALL FUNCT(FUNC)
08800		GO TO 15
08900	1051	CALL DPYCLR
09000	105	KT=KT-1
09100		IF(KT.LT.1)GO TO 281
09200		KZ=KT
09300		GO TO 1032
09400	C   CLEARS ARRAY
09500	103	READ(1,30)(A(KT,K),K=1,4)
09600	102	H=A(KT,1)
09700		IF(H.EQ.0.OR.H.EQ.999.)GO TO 2200
09800		IF(H)GO TO 115
09900		IF(H.EQ.99.)GO TO 105
10000		AMP=A(KT,2)
10100		PH=A(KT,3)
10200		CON=A(KT,4)
10300		X=PH*512./360.+1.0
10400	C  PHASE IS IN DEGREES (0 - 360)
10500	2016	DO 17 K=1,512
10600		XK=SIND(X*FAC)*AMP+CON
10700		IF(CON.LT.100.0)GO TO 1
10800		FUNC(K)=(XK-100.)*FUNC(K)
10900		GO TO 2
11000	1	FUNC(K)=FUNC(K)+XK
11100	2	X=X+H
11200	17	IF(X.GT.512.)X=X-512.
11300		KT=KT+1
11400		IF(KZ.LE.KT)CALL DPY(FUNC)
11500		GO TO 104
11600	2200	X=FUNC(1)
11700		DO 19 K=2,512
11800		XK=ABS(FUNC(K))
11900	19	IF(X.LT.XK)X=XK
12000		DO 20 K=1,512
12100	20	FUNC(K)=FUNC(K)/X
12200		CALL DPY(FUNC)
12300	200	IF(Z.EQ.0)GO TO 4200
12400		TYPE 21
12500	C   CHANGE IT?
12600		ACCEPT 40,Z
12700		IF(Z.EQ.'E')CALL EXIT
12800		Z=0
12900		DO 101 K=1,512
13000	101	FUNC(K)=FUNC(K)*X
13100	C  TO MAKE RESULT ALWAYS HONEST.
13200		GO TO 104
13300	4200	IF(EY.EQ.'EG')GO TO 7
13400		TYPE 27
13500	C  FINISH SYNTH
13600		ACCEPT 30,X
13700		IF(X.NE.0.0)GO TO 1032
13800	900	TYPE 41
13900	C  ADD TO EXISTING FILE
14000		ISKP=0
14100		ACCEPT 40,Z
14200		IF(Z.EQ.' '.OR.Z.EQ.'9')GO TO 4200
14300		TYPE 25
14400		ACCEPT 39,FLNM
14500		IF(FLNM.EQ.'99'.OR.FLNM.EQ.' ')GO TO 4200
14600		IF(Z.EQ.'N')GO TO 911
14700		REWIND 1
14800		CALL IFILE(1,FLNM)
14900		READ(1,39),X,B
15000		TYPE 44
15100	C  FUNCS. IN FILE
15200		TYPE 40,B
15300	922	REWIND 20
15400		WRITE(20,39),X,B
15500		READ (1,38),X,Y
15600	CC	WRITE(20,38),X,Y
15700		IF(ON.NE.'D')GO TO 911
15800	90	READ(1,38,END=92)X,Y,FNX,B
15900		IF(ISKP.AND.X.NE.'SEG'.AND.X.NE.'SYNTH')GO TO 90
16000		ISKP=0
16100		IF(FNX.EQ.FNUM)GO TO 921
16200		WRITE(20,38)X,Y,FNX,B
16300		GO TO 90
16400	921	ISKP=-1
16500		GO TO 90
16600	C WRITES TEMPORARY FILE 'FOR20.DAT'.
16700	92	END FILE 20
16800	CC	CALL OFILE(1,FLNM)
16900		REWIND 20
17000		READ(20,39),X,B
17100		DO 93 K=2,20
17200		X=B(K)
17300		IF(X.NE.' ')GO TO 931
17400		B(K)=','
17500		B(K+1)=FNUM
17600		GO TO 94
17700	931	IF(X.NE.FNUM)GO TO 93
17800		IF(ON.EQ.'D')FNUM=' '
17900		DO 932 L=K,20
18000		B(L)=B(L+2)
18100		IF(B(L).NE.' ')GO TO 932
18200		IF(B(L+1).EQ.' ')GO TO 941
18300	C  NO COMMA=LAST ITEM
18400		IF(FNUM.NE.' ')B(L)=','
18500		B(L+1)=FNUM
18600	CC	IF(B(L-1).EQ.',')B(L-1)=' '
18700	C  TO DELETE LAST ','
18800		GO TO 94
18900	941	B(L)=FNUM
19000		GO TO 94
19100	932	CONTINUE
19200		B(20)=FNUM
19300		B(19)=','
19400		IF(FNUM.EQ.' ')B(19)=FNUM
19500	C  REPLACES LAST ITEM IN FILE.
19600		GO TO 94
19700	93	CONTINUE
19800		TYPE 43,FLNM
19900	C  NO ROOM IN FILE.
20000		TYPE 40,B
20100		GO TO 900
20200	911	TYPE 24
20300	C  FUNCTION NAME
20400		ACCEPT 39,FNUM
20500		IF(FNUM.EQ.'99'.OR.FNUM.EQ.' ')GO TO 900
20600		IF(Z.NE.'N')GO TO 90
20700		DO 9001 K=1,21
20800	9001	B(K)=' '
20900		B(2)=FNUM
21000	94	DO 942 K=19,3,-2
21100		IF(B(K).EQ.' ')GO TO 942
21200		IF(B(K+1).EQ.' ')B(K)=' '
21300		GO TO 943
21400	942	CONTINUE
21500	C  DELETES ANY TRAILING COMMA
21600	943	REWIND 1
21700		CALL OFILE(1,FLNM)
21800		X='ARRAY'
21900		WRITE(1,39),X,B
22000		WRITE(1,45)
22100		IF(Z.EQ.'N')GO TO 97
22200	95	READ(20,38,END=96)B
22300		WRITE(1,38)B
22400		GO TO 95
22500	96	IF(ON.EQ.'D')CALL EXIT
22600	CC96	IF(ON.EQ.'D')GO TO 904
22700	97	X='SYNTH'
22800		J=4
22900		Y='   99'
23000		IF(EY.NE.'EG')GO TO 901
23100		J=2
23200		X='SEG  '
23300		Y=' '
23400	901	WRITE(1,34),X,FNUM,Y
23500	903	DO 902 K=1,KT-1
23600	902	WRITE(1,37)(A(K,L),L=1,J)
23700		IF(A(KT-1,2).GT.512.)GO TO 950
23800		IF(EY.EQ.'EG'21500	C  DELETES ANY TRAILING COMMA
21600	943	REWIND 1
21700		CALL OFILE(1,FLNM)
21800		X='ARRAY'
21900		WRITE(1,39),X,B
22000		WRITE(1,45)
22100		IF(Z.EQ.'N')GO TO 97
22200	95	READ(20,38,END=96)B
22300		WRITE(1,38)B
22400		GO TO 95
22500	96	IF(ON.EQ.'D')CALL EXIT
22600	CC96	IF(ON.EQ.'D')GO TO 904
22700	97	X='SYNTH'
22800		J=4
22900		Y='   99'
23000		IF(EY.NE.'EG')GO TO 901
23100		J=2
23200		X='SEG  '
23300		Y=' '
23400	901	WRITE(1,34),X,FNUM,Y
23500	903	DO 902 K=1,KT-1
23600	902	WRITE(1,37)(A(K,L),L=1,J)
23700		IF(A(KT-1,2).GT.512.)GO TO 950
23800		IF(EY.EQ.'EG')GO TO 904
23900		X=999.
24000		WRITE(1,37)X
24100	CC904	END FILE 1
24200	904	TYPE 35,FNUM,FLNM
24300		IF(Z.NE.'N')TYPE 36
24400		CALL EXIT
24500	
24600	CC950	WRITE(1,34),X,FNUM
24700	CC	X=99.00
24800	CC	WRITE(1,37),X
24900	950	DO 951 K=1,512,4
25000	951	WRITE(1,37),(FUNC(J),J=K,K+3)
25100		GO TO 904
25200	
25300	801	READ(1,30)AMP,STEP
25400	CC	ICURVE=STEP/5.120+.2
25500		ICURVE=STEP
25600	CC	IF(STEP.GT.512.)STEP=512.
25700		IF(STEP.GT.100.)STEP=100.
25800		GO TO 506
25900	802	CALL DPYSET(1,ST,30)
26000		CALL DPYBRT(1)
26100		KT=1
26200	800	ST(1)=0.0
26300		DO 501 K=-256,256,128
26400		IF(K.EQ.0)GO TO 501
26500		CALL ALINE(-160,K,356,K)
26600	501	CONTINUE
26700		DO 502 K=-156,356,128
26800	502	CALL ALINE(K,-260,K,256)
26900		CALL ALINE(-160,0,356,0)
27000		CALL DPYOUT(1)
27100		EY='EG'
27200		X=0
27300		Y=0
27400		KT=1
27500		N=-156
27600		CALL DPY(FUNC)
27700	701	CALL HYDPOG(2)
27800		CALL DPYSET(2,SU,270)
27900		CALL DPYBRT(5)
28000	CC	CALL AIVECT(-256,0)
28100		CALL FUNCT(FUNC)
28200	504	IF(Z)GO TO 801
28300		IF(KT.GE.KZ)GO TO 507
28400		AMP=A(KT,1)
28500		STEP=A(KT,2)
28600	CC	ICURVE=STEP/5.12+.2
28700		ICURVE=STEP
28800		GO TO 506
28900	507	TYPE 26
29000		KZ=0
29100		ACCEPT 30,AMP,STEP
29200	5071	ICURVE=STEP+.2
29300		IF(STEP.GT.100)STEP=100
29400	CC	JSTP=STEP*5.12+.001
29500	CC	STEP=JSTP
29600	CC	STEP=IFIX(STEP*5.12+.001)
29700	508	IF(AMP.NE.99..AND.STEP.GE.0)GO TO 506
29800	509	KT=KT-1
29900		IF(KT.LT.1)GO TO 281
30000		KZ=KT
30100	C DOES NOT WORK YET.  TYPE 99 FOR 'AMP' OR -1 FOR 'STEP#' TO ERASE LAST ITEM.
30200		CALL CLRPOG(2)
30300		GO TO 802
30400	506	IT=X
30500		DIF=AMP-Y
30600		STPS=STEP-X
30700		IF(STPS.LE.0.AND.KT.NE.1)GO TO 504
30800	C  CANNOT BACKUP UNLESS YOU TYPE 99 FOR AMP. OR -1 FOR STEP.
30900		IS=STPS
31000		DO 2031 K=1,IS 
31100		RK=K
31200	2031	FUNC(K+IT)=Y+DIF*RK/STPS
31300		IF(STEP.LE.1.)GO TO 12
31400	203	JX=X*5.120
31500		KX=STEP*5.120
31600		I=AMP*256.
31700		IZ=Y*256.
31800		CALL ALINE(N+JX,IZ,N+KX,I)
31900		CALL DPYOUT(2)
32000	12	Y=AMP
32100		X=STEP
32200		A(KT,1)=Y
32300		A(KT,2)=X
32400		IF(ICURVE.GT.100)GO TO 7000
32500	7001	KT=KT+1
32600	CC	IF(STEP.LT.512.)GO TO 504
32700	CC	IF(STEP-512.)504,7,7000
32800		IF(STEP-100.)504,7,7000
32900	7	TYPE 27
33000		ACCEPT 30,X
33100		Z=0
33200		IF(X.EQ.99.)GO TO 509
33300	C  X=-1 CHANGES LAST ENTRY.
33400		IF(X.EQ.1)GO TO 802
33500		GO TO 900
33600	
33700	7000	CALL SSS(A,KT,FUNC)
33800		CALL DPY(FUNC)
33900		A(KT,2)=520
34000		GO TO 7001
34100		END
34200	
34300		SUBROUTINE FUNCT(FUNC)
34400		DIMENSION FUNC(1)
34500		DO 1 K=1,512
34600	1	FUNC(K)=0
34700		RETURN
34800		END
34900	
35000	C  ********** DISPLAY OUTPUT **********
35100		SUBROUTINE DPY(FUNC)
35200		COMMON ST(30),SU(270),K,I,IY
35300		DIMENSION FUNC(1)
35400	2	CALL DPYSET(2,SU,270)
35500		CALL DPYBRT(5)
35600	CC	CALL AIVECT(0,0)
35700		IY=FUNC(1)*256.0
35800		CALL AIVECT(-156,IY)
35900		DO 1017 K=2,512
36000		I=FUNC(K)*256.0
36100		CALL SVECT(1,I-IY)
36200	1017	IY=I
36300		CALL DPYOUT(2)
36400		RETURN
36500		END